package frege.control.trans.EitherT where

import frege.Prelude (Monad, Applicative, Functor, Either, $, <~, liftM, id)
import frege.control.Monoid
import frege.control.trans.MonadTrans
import frege.control.trans.MonadIO

data EitherT l m a = EitherT { run :: m (Either l a) }


inEitherT0 :: m (Either l a) -> EitherT l m a
inEitherT0 x = EitherT x
inEitherT1 :: (m (Either l a) -> m (Either l b)) ->
              EitherT l m a -> EitherT l m b
inEitherT1 f x = inEitherT0 $ f $ EitherT.run x
inEitherT2 :: (m (Either l a) -> m (Either l b) -> m (Either l c)) ->
              EitherT l m a -> EitherT l m b -> EitherT l m c
inEitherT2 f x y = inEitherT1 (f $ EitherT.run x) y

left :: Monad m => l -> EitherT l m a
left x = EitherT $ return $ Left x

instance Monad Monad m => (EitherT l m) where
  -- We can't support "fail" because we don't have a
  -- (String -> l). But we can at least make it a Left, with the error inside
  -- it as a pure exception.
  --fail = EitherT . return . Left . error
  return x = EitherT $ return $ Right x
  EitherT x >>= f = EitherT $ do
    res <- x
    case res of
      Right r -> EitherT.run $ f $ r
      Left l -> return (Left l)

instance MonadTrans (EitherT l) where
  lift x = EitherT $ liftM Right x
{-
instance Functor Functor f => (EitherT l) f where
  fmap = inEitherT1 <~ fmap <~ fmap

  
instance Applicative Applicative f => (EitherT l) f where
  return x = EitherT $ return $ Right x
  (<*>) = inEitherT2 <~ liftA2 <~ liftA2 $ id

private liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
private liftA2 f a b = f `fmap` a <*> b
-}
instance MonadIO MonadIO m => EitherT l m where
  liftIO = lift <~ liftIO

{-
instance Monoid (Applicative m, Monoid a) => EitherT l m a where
  mempty = return mempty
  mappend = liftA2 mappend
  -}